home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Runtime (.scm & .s) / mac_ext.scm < prev   
Encoding:
Text File  |  1992-12-10  |  20.5 KB  |  366 lines  |  [TEXT/gamI]
  1. (##declare
  2.   (multilisp)
  3.   (extended-bindings)
  4.   (not safe)
  5.   (not autotouch)
  6.   (block)
  7.   (fixnum)
  8.   (not intr-checks))
  9.  
  10. ;------------------------------------------------------------------------------
  11.  
  12. ; Utilities
  13.  
  14. (define (mac#unsigned16->signed16 x) ; ##vector16-ref returns 0..65535
  15.   (##fixnum.- (##fixnum.modulo (##fixnum.+ x 32768) 65536) 32768))
  16.  
  17. ; Macintosh events
  18.  
  19. (define (mac#event-what ev)
  20.   (##vector16-ref ev 0))
  21. (define (mac#event-message ev)
  22.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 1) 65536) (##vector16-ref ev 2)))
  23. (define (mac#event-when ev)
  24.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 3) 65536) (##vector16-ref ev 4)))
  25. (define (mac#event-where ev)
  26.   (mac#point (##vector16-ref ev 5) (##vector16-ref ev 6)))
  27. (define (mac#event-modifiers ev)
  28.   (##vector16-ref ev 7))
  29.  
  30. (define (mac#modifiers-button? modifiers)
  31.   (##fixnum.zero? (##fixnum.logand modifiers 128)))
  32.  
  33. (define (mac#modifiers-command? modifiers)
  34.   (##not (##fixnum.zero? (##fixnum.logand modifiers 256))))
  35.  
  36. (define (mac#modifiers-shift? modifiers)
  37.   (##not (##fixnum.zero? (##fixnum.logand modifiers 512))))
  38.  
  39. (define (mac#modifiers-alphalock? modifiers)
  40.   (##not (##fixnum.zero? (##fixnum.logand modifiers 1024))))
  41.  
  42. (define (mac#modifiers-option? modifiers)
  43.   (##not (##fixnum.zero? (##fixnum.logand modifiers 2048))))
  44.  
  45. ; Quickdraw points
  46.  
  47. (define (mac#point v h)
  48.   (let ((p (##make-vector16 2 0)))
  49.     (##vector16-set! p 0 v)
  50.     (##vector16-set! p 1 h)
  51.     p))
  52.  
  53. (define (mac#point-v r) (mac#unsigned16->signed16 (##vector16-ref r 0)))
  54. (define (mac#point-h r) (mac#unsigned16->signed16 (##vector16-ref r 1)))
  55. (define (mac#point-v-set! r x) (##vector16-set! r 0 x))
  56. (define (mac#point-h-set! r x) (##vector16-set! r 1 x))
  57.  
  58. ; Quickdraw rectangles
  59.  
  60. (define (mac#rect top left bottom right)
  61.   (let ((r (##make-vector16 4 0)))
  62.     (##vector16-set! r 0 top)
  63.     (##vector16-set! r 1 left)
  64.     (##vector16-set! r 2 bottom)
  65.     (##vector16-set! r 3 right)
  66.     r))
  67.  
  68. (define (mac#rect-top r)    (mac#unsigned16->signed16 (##vector16-ref r 0)))
  69. (define (mac#rect-left r)   (mac#unsigned16->signed16 (##vector16-ref r 1)))
  70. (define (mac#rect-bottom r) (mac#unsigned16->signed16 (##vector16-ref r 2)))
  71. (define (mac#rect-right r)  (mac#unsigned16->signed16 (##vector16-ref r 3)))
  72. (define (mac#rect-top-set! r x)    (##vector16-set! r 0 x))
  73. (define (mac#rect-left-set! r x)   (##vector16-set! r 1 x))
  74. (define (mac#rect-bottom-set! r x) (##vector16-set! r 2 x))
  75. (define (mac#rect-right-set! r x)  (##vector16-set! r 3 x))
  76.  
  77. ; Quickdraw procedures
  78.  
  79. (define (mac#newwindow bounds title visible procid behind goaway)
  80.   (mac_#newwindow bounds title visible procid behind goaway))
  81.  
  82. (define (mac#getnewwindow windowid behind)
  83.   (mac_#getnewwindow windowid behind))
  84.  
  85. (define (mac#disposewindow w)
  86.   (mac_#disposewindow w))
  87.  
  88. (define (mac#selectwindow w)
  89.   (mac_#selectwindow w))
  90.  
  91. (define (mac#hidewindow w)
  92.   (mac_#hidewindow w))
  93.  
  94. (define (mac#showwindow w)
  95.   (mac_#showwindow w))
  96.  
  97. (define (mac#frontwindow)
  98.   (mac_#frontwindow))
  99.  
  100. (define (mac#findwindow pt w-cell)
  101.   (mac_#findwindow pt w-cell))
  102.  
  103. (define (mac#trackgoaway w pt)
  104.   (mac_#trackgoaway w pt))
  105.  
  106. (define (mac#dragwindow w pt r)
  107.   (mac_#dragwindow w pt r))
  108.  
  109. (define (mac#invalrect port r)
  110.   (mac_#invalrect port r))
  111.  
  112. (define (mac#beginupdate w)
  113.   (mac_#beginupdate w))
  114.  
  115. (define (mac#endupdate w)
  116.   (mac_#endupdate w))
  117.  
  118. (define (mac#openport port) (mac_#openport port))
  119. (define (mac#initport port) (mac_#initport port))
  120. (define (mac#closeport port) (mac_#closeport port))
  121. (define (mac#setport port) (mac_#setport port))
  122. (define (mac#getport) (mac_#getport))
  123. (define (mac#setorigin port h v) (mac_#setport port h v))
  124. (define (mac#backpat port pat) (mac_#backpat port pat))
  125. (define (mac#hidecursor) (mac_#hidecursor))
  126. (define (mac#showcursor) (mac_#showcursor))
  127. (define (mac#pensize port width height) (mac_#pensize port width height))
  128. (define (mac#penmode port mode) (mac_#penmode port mode))
  129. (define (mac#penpat port pat) (mac_#penpat port pat))
  130. (define (mac#pennormal port) (mac_#pennormal port))
  131. (define (mac#moveto port h v) (mac_#moveto port h v))
  132. (define (mac#move port dh dv) (mac_#move port dh dv))
  133. (define (mac#lineto port h v) (mac_#lineto port h v))
  134. (define (mac#line port dh dv) (mac_#line port dh dv))
  135. (define (mac#textfont port font) (mac_#textfont port font))
  136. (define (mac#textface port face) (mac_#textface port face))
  137. (define (mac#textmode port mode) (mac_#textmode port mode))
  138. (define (mac#textsize port size) (mac_#textsize port size))
  139. (define (mac#spaceextra port extra) (mac_#spaceextra port extra))
  140. (define (mac#drawchar port ch) (mac_#drawchar port ch))
  141. (define (mac#drart and complete before the processing of the
  142.   ; original event is finished.
  143.   ;
  144.   ; To solve this problem, this procedure is written so that it
  145.   ; does not cons and does not allow interrupts (interrupt checks are
  146.   ; not generated inside the procedure and no procedure which might check
  147.   ; interrupts is called).  To prevent consing this procedure mutates
  148.   ; constants (this is OK in Gambit even though it is an error in IEEE-Scheme).
  149.   ;
  150.   ; In addition, each window has an associated queue of pending events.
  151.   ; Only one event per window can be processed at a time.  If an event is
  152.   ; generated for a particular window and that window is still processing a
  153.   ; previous event, the event is put on the window's queue.  When the
  154.   ; processing of an event ends, the next event on the queue is processed (if
  155.   ; there is one).  Unfortunately, this means that if the processing of an
  156.   ; event is aborted (due to an error or user interrupt), the window will
  157.   ; not accept any new events.  The procedure call (mac#window-reset wind)
  158.   ; can be used to reenable the processing of new events on the window 'wind'.
  159.   ;
  160.   ; The processing of a window's events is done in a task (created by a
  161.   ; future).  This means that multiple windows may be "running" concurrently
  162.   ; with the main program.  This introduces the usual multitasking problems.
  163.   ; Shared data structures should be protected with semaphores to guarantee
  164.   ; that only one task is accessing them at any given point in time.
  165.  
  166.   (let* ((what (##vector16-ref event 0))
  167.          (message (##fixnum.+ (##fixnum.* (##vector16-ref event 1) 65536)
  168.                               (##vector16-ref event 2)))
  169.          (w-cell '(0)) ; these two constants get mutated (to avoid consing)
  170.          (where "1234"))
  171.     (cond ((or (##fixnum.= what 1)  ; mousedown event
  172.                (##fixnum.= what 2)) ; mouseup event
  173.            (##vector16-set! where 0 (##vector16-ref event 5)) ; mutate 'where'
  174.            (##vector16-set! where 1 (##vector16-ref event 6))
  175.            (let* ((in (mac#findwindow where w-cell)) ; mutate 'w-cell'
  176.                   (w (##car w-cell))
  177.                   (wind-struct (mac#window-lookup w)))
  178.              (if wind-struct
  179.                (cond ((##fixnum.= in 3) ; incontent
  180.                       (if (##fixnum.= w (mac#frontwindow))
  181.                         (begin
  182.                           (mac#globaltolocal w where)
  183.                           (##vector16-set! event 5 (##vector16-ref where 0))
  184.                           (##vector16-set! event 6 (##vector16-ref where 1))
  185.                           (mac#window-handle-event wind-struct event))
  186.                         (begin
  187.                           (if (##fixnum.= what 1) (mac#selectwindow w))
  188.                           #f)))
  189.                      ((##fixnum.= in 4) ; indrag
  190.                       (if (##fixnum.= what 1)
  191.                         (mac#dragwindow w where mac#window-drag-bounds))
  192.                       #f)
  193.                      ((##fixnum.= in 6) ; ingoaway
  194.                       (if (and (##fixnum.= what 1) (mac#trackgoaway w where))
  195.                         (begin
  196.                           (##vector16-set! event 0 0)
  197.                           (mac#window-handle-event wind-struct event))
  198.                         #f)))
  199.                (##os-handle-event event))))
  200.           ((or (##fixnum.= what 3)  ; keydown event
  201.                (##fixnum.= what 4)  ; keyup event
  202.                (##fixnum.= what 5)) ; autokey event
  203.            (if (mac#modifiers-command? (##vector16-ref event 7)) ; command?
  204.              (##os-handle-event event)
  205.              (let* ((w (mac#frontwindow))
  206.                     (wind-struct (mac#window-lookup w)))
  207.                (if wind-struct
  208.                  (mac#window-handle-event wind-struct event)
  209.                  (##os-handle-event event)))))
  210.           ((##fixnum.= what 6) ; update event
  211.            (let ((wind-struct (mac#window-lookup message)))
  212.              (if wind-struct
  213.                (begin
  214.                  (mac#beginupdate message) ; discard update region
  215.                  (mac#endupdate message)
  216.                  (mac#window-handle-event wind-struct event))
  217.                (##os-handle-event event))))
  218.           ((##fixnum.= what 8) ; activate and deactivate events
  219.            (let ((wind-struct (mac#window-lookup message)))
  220.              (if wind-struct
  221.                (mac#window-handle-event wind-struct event)
  222.                (##os-handle-event event))))
  223.           (else
  224.            (##os-handle-event event)))))
  225.  
  226. (set! ##handle-os-event mac#event-handler)
  227.  
  228. ;------------------------------------------------------------------------------
  229.  
  230. ; Drawing window
  231.  
  232. (define clear-graphics #f)
  233. (define position-pen #f)
  234. (define draw-line-to #f)
  235. (define draw-point #f)
  236. (define clear-point #f)
  237. (define graphics-text #f)
  238.  
  239. (let ()
  240.  
  241.   (define top     40)
  242.   (define right   510)
  243.   (define y-max   200.) ; must be inexact (flonum)
  244.   (define x-max   200.) ;   "        "
  245.   (define scaling .5)   ;   "        "
  246.   (define visible? #f)
  247.  
  248.   (define (cx x)
  249.     (##flonum.->fixnum
  250.       (##flonum.* (##flonum.+ x-max (##real-part (##exact->inexact x)))
  251.                   scaling)))
  252.  
  253.   (define (cy y)
  254.     (##flonum.->fixnum
  255.       (##flonum.* (##flonum.- y-max (##real-part (##exact->inexact y)))
  256.                   scaling)))
  257.  
  258.   (let* ((clear-rect (mac#rect -32000 -32000 32000 32000))
  259.          (width (##flonum.->fixnum (##flonum.* (##flonum.* 2. x-max) scaling)))
  260.          (height (##flonum.->fixnum (##flonum.* (##flonum.* 2. y-max) scaling)))
  261.          (w (mac#newwindow
  262.               (mac#rect top (##fixnum.- right width) (##fixnum.+ top height) right)
  263.               "Drawing" visible? 19 (if visible? -1 0) #t))
  264.          (head (##cons #f '()))
  265.          (tail head)
  266.          (pen-x0 (cx 0))
  267.          (pen-y0 (cy 0))
  268.          (pen-x #f)
  269.          (pen-y #f))
  270.  
  271.     (define (wind msg)
  272.       (cond ((##eq? msg 'GOAWAY) goaway)
  273.             ((##eq? msg 'UPDATE) update)
  274.             (else                ##list))) ; discard other events
  275.  
  276.     (define (goaway)
  277.       (mac#hidewindow w))
  278.  
  279.     (define (update)
  280.       (set! pen-x pen-x0)
  281.       (set! pen-y pen-y0)
  282.       (let loop ((l (##cdr head)))
  283.         (if (##pair? l)
  284.           (begin ((##car l)) (loop (##cdr l))))))
  285.  
  286.     (define (show)
  287.       (if (##fixnum.zero? (mac#peek8 (##fixnum.+ w 110))) ; not visible?
  288.         (begin
  289.           (mac#showwindow w)      ; make it visible
  290.           (mac#selectwindow w)))) ; and in front of all other windows
  291.  
  292.     (define (clear)
  293.       (##set-cdr! head '())
  294.       (set! tail head)
  295.       (mac#eraserect w clear-rect))
  296.  
  297.     (define (add action)
  298.       (let ((x (##cons action '())))
  299.         (##set-cdr! tail x)
  300.         (set! tail x)
  301.         (show)
  302.         (action)))
  303.  
  304.     (define (init)
  305.       (set! pen-x pen-x0)
  306.       (set! pen-y pen-y0)
  307.       (clear))
  308.  
  309.     (define (make-position-pen x y)
  310.       (lambda ()
  311.         (set! pen-x x)
  312.         (set! pen-y y)))
  313.  
  314.     (define (make-draw-line-to x y)
  315.       (lambda ()
  316.         (mac#moveto w pen-x pen-y)
  317.         (mac#lineto w x y)
  318.         (set! pen-x x)
  319.         (set! pen-y y)))
  320.  
  321.     (define (make-draw-point x y)
  322.       (lambda ()
  323.         (mac#moveto w x y)
  324.         (mac#lineto w x y)))
  325.  
  326.     (define (make-clear-point x y)
  327.       (lambda ()
  328.         (mac#penmode w 11) ; patBic
  329.         (mac#moveto w x y)
  330.         (mac#lineto w x y)
  331.         (mac#penmode w 8))) ; patCopy
  332.  
  333.     (define (make-graphics-text text x y)
  334.       (lambda ()
  335.         (mac#moveto w x y)
  336.         (mac#drawstring w text)))
  337.  
  338.     (set! clear-graphics
  339.       (lambda () (show) (clear) #f))
  340.  
  341.     (set! position-pen
  342.       (lambda (x y) (add (make-position-pen (cx x) (cy y))) #f))
  343.  
  344.     (set! draw-line-to
  345.       (lambda (x y) (add (make-draw-line-to (cx x) (cy y))) #f))
  346.  
  347.     (set! draw-point
  348.       (lambda (x y) (add (make-draw-point (cx x) (cy y))) #f))
  349.  
  350.     (set! clear-point
  351.       (lambda (x y) (add (make-clear-point (cx x) (cy y))) #f))
  352.  
  353.     (set! graphics-text
  354.       (lambda (text x y)
  355.         (if (##string? text) (add (make-graphics-text text (cx x) (cy y))))
  356.         #f))
  357.  
  358.     (mac#textfont w 4) ; monaco
  359.     (mac#textsize w 9)
  360.  
  361.     (init)
  362.  
  363.     (mac#window-bind w wind)))
  364.  
  365. ;------------------------------------------------------------------------------
  366.